(*
  Copyright (c) 2009 Barry Schwartz

  Permission is hereby granted, free of charge, to any person
  obtaining a copy of this software and associated documentation
  files (the "Software"), to deal in the Software without
  restriction, including without limitation the rights to use,
  copy, modify, merge, publish, distribute, sublicense, and/or sell
  copies of the Software, and to permit persons to whom the
  Software is furnished to do so, subject to the following
  conditions:

  The above copyright notice and this permission notice shall be
  included in all copies or substantial portions of the Software.

  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
  OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
  HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
  WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
  OTHER DEALINGS IN THE SOFTWARE.
*)

open IO_Base
open XNum
open UniTools
  
let num_0x100 = num_of_int 0x100
let num_0x10000 = num_of_int 0x10000
let num_0x1000000 = num_of_int 0x1000000
let num_0x100000000 = mult_num num_0x10000 num_0x10000
let num_0x80000000 = div_num num_0x100000000 (num_of_int 2)
  
type istream = IO_Base.istream
type irstream = IO_Base.irstream
type ostream = IO_Base.ostream
type orstream = IO_Base.orstream
type iostream = IO_Base.iostream
type iorstream = IO_Base.iorstream

let coerce_i = io_coerce_i
let coerce_o = io_coerce_o
let coerce_ir = io_coerce_ir
let coerce_or = io_coerce_or
let coerce_io = io_coerce_io
let coerce_ior = io_coerce_ior
  
(* IO routines ************************************************************************************)
let size = io_size
let pos = io_pos
let seek = io_seek
let bytes_written = io_bytes_written
let eof = io_eof
let free = io_free
let read_char = io_read_char
let read_string = io_read_string
let write_char = io_write_char
let write_string = io_write_string
let skip cs off = ignore (io_read_string cs off)
  
(* reading from a stream *)
let read_byte cs =
  if io_eof cs then
    (-1)
  else
    int_of_char (io_read_char cs)
  
let peek_char cs off =
  let pos = io_pos cs in
    io_seek cs (pos + off);
    let chr = io_read_char cs in
      io_seek cs pos;
      chr
  
let rec peek_string cs off len =
  let pos = io_pos cs in
    io_seek cs (pos + off);
    let str = io_read_string cs len in
      io_seek cs pos;
      str
  
let skip_while cs p =
  while (not (io_eof cs)) && (p (peek_char cs 0)) do
    skip cs 1
  done
  
(* reading bigendian integers *)
let read_be_u8 cs = read_byte cs
  
let read_be_u16 cs =
  let x = read_byte cs in
  let y = read_byte cs in
    (0x100 * x) + y
  
let read_be_u24 cs =
  let x = read_byte cs in
  let y = read_byte cs in
  let z = read_byte cs in
    ((0x10000 * x) + (0x100 * y)) + z
  
let read_be_u32 cs =
  let x = read_be_u16 cs in
  let y = read_be_u16 cs in
    add_num (mult_num (num_of_int 0x10000) (num_of_int x)) (num_of_int y)
  
let read_be_i8 cs =
  let x = read_be_u8 cs in
    if x > 0x7f then
      x - 0x100
    else
      x
  
let read_be_i16 cs =
  let x = read_be_u16 cs in
    if x > 0x7fff then
      x - 0x10000
    else
      x
  
let read_be_i24 cs =
  let x = read_be_u24 cs in
    if x > 0x7fffff then
      x - 0x1000000
    else
      x
  
let read_be_i32 cs =
  let x = read_be_u32 cs in
    if ge_num x num_0x80000000 then
      sub_num x num_0x100000000
    else
      x
  
(* writing to a stream *)
let write_byte cs x = io_write_char cs (Char.unsafe_chr (x land 0xff))
let printf cs = Printf.kprintf (write_string cs)
let write_be_u8 cs x = write_byte cs x

let write_be_u16 cs x =
  write_byte cs ((x lsr 8) land 0xff);
  write_byte cs (x land 0xff)
  
let write_be_u24 cs x =
  write_byte cs ((x lsr 16) land 0xff);
  write_byte cs ((x lsr 8) land 0xff);
  write_byte cs (x land 0xff)
  
let write_be_u32 cs n =
  let y = mod_num n (num_of_int 0x10000) in
  let x = quo_num (sub_num n y) (num_of_int 0x10000) in
  let u = int_of_num x in
  let v = int_of_num y in
  let b = (0x10000 + u) mod 0x100 in
  let a = (u - b) / 0x100 in
  let d = (0x10000 + v) mod 0x100 in
  let c = (v - d) / 0x100 in
    write_byte cs a;
    write_byte cs b;
    write_byte cs c;
    write_byte cs d
  
let write_be_i8 cs x =
  if x < 0 then
    write_byte cs (0x100 + x)
  else
    write_byte cs x
  
let write_be_i16 cs x =
  if x < 0 then
    write_be_u16 cs (0x10000 + x)
  else
    write_be_u16 cs x
  
let write_be_i24 cs x =
  if x < 0 then
    write_be_u24 cs (0x1000000 + x)
  else
    write_be_u24 cs x
  
let write_be_i32 cs n =
  let y = mod_num n (num_of_int 0x10000) in
  let x = quo_num (sub_num n y) (num_of_int 0x10000) in
  let u = int_of_num x in
  let v = int_of_num y in
  let b = (0x10000 + u) mod 0x100 in
  let a = (u - b) / 0x100 in
  let d = (0x10000 + v) mod 0x100 in
  let c = (v - d) / 0x100 in
    if a < 0 then
      write_byte cs (a + 0x100)
    else
      write_byte cs a;
    write_byte cs b;
    write_byte cs c;
    write_byte cs d
  
let read_utf8_char cs =
  let c = read_byte cs
  in
    if c < 0x80
    then c
    else
      if c < 0xc0
      then c
      else (* should never happen *)
        if c < 0xe0
        then
          (let c2 = read_byte cs
           in
             if c2 < 0
             then 0x40 * (c - 0xc0)
             else ((0x40 * (c - 0xc0)) + c2) - 0x80)
        else
          (let c2 = read_byte cs in
           let c3 = read_byte cs
           in
             if c2 < 0
             then 0x1000 * (c - 0xe0)
             else
               if c3 < 0
               then (0x1000 * (c - 0xe0)) + (0x40 * (c2 - 0x80))
               else
                 (((0x1000 * (c - 0xe0)) + (0x40 * (c2 - 0x80))) + c3) - 0x80)
  
let write_utf8_char cs x =
  if x < 0x80
  then write_byte cs x
  else
    if x < 0x800
    then
      (write_byte cs (0xc0 + (x lsr 6));
       write_byte cs (0x80 + (x land 0x3f)))
    else
      (write_byte cs (0xe0 + (x lsr 12));
       write_byte cs (0x80 + ((x lsr 6) land 0x3f));
       write_byte cs (0x80 + (x land 0x3f)))
  
(* Implementations ********************************************************************************)

(* |power_of_two <x>| returns the greatest power of two less than or equal to <x>. *)
let power_of_two x =
  let rec iter p x =
    if x = 0 then
      p lsr 1
    else
      iter (p lsl 1) (x lsr 1)
  in
    iter 1 x
  
(* in_channels *)
let in_channel_read_char ic eof =
  try
    input_char ic
  with
    | End_of_file -> (eof := true; '\000')
  
let in_channel_read_string ic eof len =
  let buf = String.create len in
  let rec iter off len =
    let read = input ic buf off len in
      if read = len then
        buf
      else if read = 0 then
        (eof := true; "")
      else
        iter (off + read) (len - read)
  in
    iter 0 len
  
let make_in_stream filename =
  let ic = open_in_bin (UniText.to_string filename) in
  let eof = ref false in
    io_make_read (fun () -> close_in ic)
      (fun () -> in_channel_read_char ic eof)
      (fun len -> in_channel_read_string ic eof len) (fun () -> !eof)
  
let make_rand_in_stream filename =
  let ic = open_in_bin (UniText.to_string filename) in
  let eof = ref false in
    io_make_read_seek (fun () -> close_in ic)
      (fun () -> in_channel_read_char ic eof)
      (fun len -> in_channel_read_string ic eof len) (fun () -> !eof)
      (fun () -> in_channel_length ic) (fun () -> pos_in ic)
      (fun off -> seek_in ic off)
  
let make_out_stream filename =
  let oc = open_out_bin (UniText.to_string filename) in
    io_make_write (fun () -> close_out oc) (fun chr -> output_char oc chr)
      (fun str -> output_string oc str) (fun () -> pos_out oc)
  
let make_rand_out_stream filename =
  let oc = open_out_bin (UniText.to_string filename) in
    io_make_write_seek (fun () -> close_out oc)
      (fun chr -> output_char oc chr) (fun str -> output_string oc str)
      (fun () -> pos_out oc) (fun () -> out_channel_length oc)
      (fun () -> pos_out oc) (fun off -> seek_out oc off)
  
let make_buffer_stream buffer_size =
  let buf_size = power_of_two (min buffer_size Sys.max_string_length) in
  let buffer = ref [| String.create buf_size |] in
  let size = ref 0 in
  let pos = ref 0 in
  let resize_buffer len =
    buffer :=
      Array.init len
        (fun i ->
           if i < (Array.length !buffer)
           then !buffer.(i)
           else String.create buf_size) in
  (* doubles the size of the buffer array *)
  let double_buffer () = resize_buffer (2 * (Array.length !buffer)) in
  (* returns the entry in the buffer array that contains the given position *)
  let rec get_buffer pos =
    if pos < (buf_size * (Array.length !buffer))
    then !buffer.(pos / buf_size)
    else (double_buffer (); get_buffer pos) in
  let get_buffer_pos pos = pos land (buf_size - 1) in
  (* returns the offset within a buffer of the given position *)
  let get_char pos = (get_buffer pos).[get_buffer_pos pos] in
  let set_char pos chr = (get_buffer pos).[get_buffer_pos pos] <- chr in
  let seek new_pos =
    if new_pos < 0
    then pos := 0
    else if new_pos >= !size then pos := !size else pos := new_pos in
  let read_char () =
    if !pos >= !size
    then '\000'
    else (let c = get_char !pos in (pos := !pos + 1; c)) in
  let rec read_string len =
    if (!pos + len) > !size
    then read_string (!size - !pos)
    else
      (let str = String.create len
       in (for i = 0 to len - 1 do str.[i] <- read_char () done; str)) in
  let write_char chr =
    (if !pos >= !size then size := !pos + 1 else ();
     set_char !pos chr;
     pos := !pos + 1) in
  let write_string str =
    for i = 0 to (String.length str) - 1 do write_char str.[i] done
  in
    io_make (fun () -> ()) read_char read_string (fun () -> !pos = !size)
      write_char write_string (fun () -> !size) (fun () -> !size)
      (fun () -> !pos) seek
  
let make_string_stream str =
  let pos = ref 0 in
  let seek new_pos =
    if new_pos < 0 then
      pos := 0
    else if new_pos >= (String.length str) then
      pos := String.length str
    else pos := new_pos in
  let read_char () =
    if !pos >= (String.length str) then
      '\000'
    else
      let c = str.[!pos] in
        (pos := !pos + 1; c)
  in
  let read_string len =
    if (!pos + len) > (String.length str) then
      String.sub str !pos ((String.length str) - !pos)
    else
      String.sub str !pos len
  in
    io_make_read_seek (fun () -> ()) read_char read_string
      (fun () -> !pos = (String.length str)) (fun () -> String.length str)
      (fun () -> !pos) seek
  
(* Conversions *)
let consume_stream is f =
  while not (io_eof is) do f (io_read_string is 0x1000) done
  
let produce_stream os f =
  let rec iter () =
    match f () with | "" -> () | str -> (io_write_string os str; iter ())
  in iter ()
  
(* Append the contents of a channel to a stream. *)
let append_channel os ic =
  let buffer = String.create 0x1000 in
  let read () = let len = input ic buffer 0 0x1000 in String.sub buffer 0 len
  in produce_stream os read
  
let append os is = consume_stream is (io_write_string os)
  
(* Write the contents of a stream to a channel. *)
let to_channel is oc = consume_stream is (output_string oc)
  
let from_string str =
  let cs = make_buffer_stream (String.length str)
  in (write_string cs str; seek cs 0; cs)
  
let to_string is =
  let buf = Buffer.create 0x1000
  in
    (seek is 0;
     consume_stream is (Buffer.add_string buf);
     Buffer.contents buf)
  
let sub_stream cs len =
  let new_cs = make_buffer_stream len
  in
    (if len <= Sys.max_string_length
     then write_string new_cs (read_string cs len)
     else
       (let rec iter i =
          if (i + Sys.max_string_length) <= len
          then
            (write_string new_cs (read_string cs Sys.max_string_length);
             iter (i + Sys.max_string_length))
          else write_string new_cs (read_string cs (len - i))
        in iter 0);
     seek new_cs 0;
     new_cs)
  
let to_buffer is = let os = make_buffer_stream 0x1000 in (append os is; os)
